home *** CD-ROM | disk | FTP | other *** search
/ Sprite 1984 - 1993 / Sprite 1984 - 1993.iso / src / cmds / perl / sprite / perl.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-11-14  |  35.0 KB  |  1,389 lines
  1. char rcsid[] = "$RCSfile: perl.c,v $$Revision: 1.3 $$Date: 91/11/14 12:52:07 $\nPatch level: ###\n";
  2. /*
  3.  *    Copyright (c) 1991, Larry Wall
  4.  *
  5.  *    You may distribute under the terms of either the GNU General Public
  6.  *    License or the Artistic License, as specified in the README file.
  7.  *
  8.  * $Log:    perl.c,v $
  9.  * Revision 1.3  91/11/14  12:52:07  jhh
  10.  * patchlevel 19
  11.  * 
  12.  * Revision 4.0.1.6  91/11/11  16:38:45  lwall
  13.  * patch19: default arg for shift was wrong after first subroutine definition
  14.  * patch19: op/regexp.t failed from missing arg to bcmp()
  15.  * 
  16.  * Revision 4.0.1.5  91/11/05  18:03:32  lwall
  17.  * patch11: random cleanup
  18.  * patch11: $0 was being truncated at times
  19.  * patch11: cppstdin now installed outside of source directory
  20.  * patch11: -P didn't allow use of #elif or #undef
  21.  * patch11: prepared for ctype implementations that don't define isascii()
  22.  * patch11: added eval {}
  23.  * patch11: eval confused by string containing null
  24.  *
  25.  * Revision 1.2  91/07/16  17:03:10  jhh
  26.  * we use some sort of non-standard sed
  27.  * 
  28.  * Revision 1.1  91/07/16  12:16:14  jhh
  29.  * Initial revision
  30.  * 
  31.  * Revision 4.0.1.4  91/06/10  01:23:07  lwall
  32.  * patch10: perl -v printed incorrect copyright notice
  33.  * 
  34.  * Revision 4.0.1.3  91/06/07  11:40:18  lwall
  35.  * patch4: changed old $^P to $^X
  36.  * 
  37.  * Revision 4.0.1.2  91/06/07  11:26:16  lwall
  38.  * patch4: new copyright notice
  39.  * patch4: added $^P variable to control calling of perldb routines
  40.  * patch4: added $^F variable to specify maximum system fd, default 2
  41.  * patch4: debugger lost track of lines in eval
  42.  * 
  43.  * Revision 4.0.1.1  91/04/11  17:49:05  lwall
  44.  * patch1: fixed undefined environ problem
  45.  * 
  46.  * Revision 4.0  91/03/20  01:37:44  lwall
  47.  * 4.0 baseline.
  48.  * 
  49.  */
  50.  
  51. /*SUPPRESS 560*/
  52.  
  53. #include "EXTERN.h"
  54. #include "perl.h"
  55. #include "perly.h"
  56. #ifdef MSDOS
  57. #include "patchlev.h"
  58. #else
  59. #include "patchlevel.h"
  60. #endif
  61.  
  62. char *getenv();
  63.  
  64. #ifdef IAMSUID
  65. #ifndef DOSUID
  66. #define DOSUID
  67. #endif
  68. #endif
  69.  
  70. #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  71. #ifdef DOSUID
  72. #undef DOSUID
  73. #endif
  74. #endif
  75.  
  76. static char* moreswitches();
  77. static char* cddir;
  78. static bool minus_c;
  79. static char patchlevel[6];
  80. static char *nrs = "\n";
  81. static int nrschar = '\n';      /* final char of rs, or 0777 if none */
  82. static int nrslen = 1;
  83.  
  84. main(argc,argv,env)
  85. register int argc;
  86. register char **argv;
  87. register char **env;
  88. {
  89.     register STR *str;
  90.     register char *s;
  91.     char *scriptname;
  92.     char *getenv();
  93.     bool dosearch = FALSE;
  94. #ifdef DOSUID
  95.     char *validarg = "";
  96. #endif
  97.  
  98. #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  99. #ifdef IAMSUID
  100. #undef IAMSUID
  101.     fatal("suidperl is no longer needed since the kernel can now execute\n\
  102. setuid perl scripts securely.\n");
  103. #endif
  104. #endif
  105.  
  106.     origargv = argv;
  107.     origargc = argc;
  108.     origenviron = environ;
  109.     uid = (int)getuid();
  110.     euid = (int)geteuid();
  111.     gid = (int)getgid();
  112.     egid = (int)getegid();
  113.     sprintf(patchlevel,"%3.3s%2.2d", index(rcsid,'4'), PATCHLEVEL);
  114. #ifdef MSDOS
  115.     /*
  116.      * There is no way we can refer to them from Perl so close them to save
  117.      * space.  The other alternative would be to provide STDAUX and STDPRN
  118.      * filehandles.
  119.      */
  120.     (void)fclose(stdaux);
  121.     (void)fclose(stdprn);
  122. #endif
  123.     if (do_undump) {
  124.     origfilename = savestr(argv[0]);
  125.     do_undump = 0;
  126.     loop_ptr = -1;        /* start label stack again */
  127.     goto just_doit;
  128.     }
  129.     (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
  130.     linestr = Str_new(65,80);
  131.     str_nset(linestr,"",0);
  132.     str = str_make("",0);        /* first used for -I flags */
  133.     curstash = defstash = hnew(0);
  134.     curstname = str_make("main",4);
  135.     stab_xhash(stabent("_main",TRUE)) = defstash;
  136.     defstash->tbl_name = "main";
  137.     incstab = hadd(aadd(stabent("INC",TRUE)));
  138.     incstab->str_pok |= SP_MULTI;
  139.     for (argc--,argv++; argc > 0; argc--,argv++) {
  140.     if (argv[0][0] != '-' || !argv[0][1])
  141.         break;
  142. #ifdef DOSUID
  143.     if (*validarg)
  144.     validarg = " PHOOEY ";
  145.     else
  146.     validarg = argv[0];
  147. #endif
  148.     s = argv[0]+1;
  149.       reswitch:
  150.     switch (*s) {
  151.     case '0':
  152.     case 'a':
  153.     case 'c':
  154.     case 'd':
  155.     case 'D':
  156.     case 'i':
  157.     case 'l':
  158.     case 'n':
  159.     case 'p':
  160.     case 'u':
  161.     case 'U':
  162.     case 'v':
  163.     case 'w':
  164.         if (s = moreswitches(s))
  165.         goto reswitch;
  166.         break;
  167.  
  168.     case 'e':
  169. #ifdef TAINT
  170.         if (euid != uid || egid != gid)
  171.         fatal("No -e allowed in setuid scripts");
  172. #endif
  173.         if (!e_fp) {
  174.             e_tmpname = savestr(TMPPATH);
  175.         (void)mktemp(e_tmpname);
  176.         e_fp = fopen(e_tmpname,"w");
  177.         if (!e_fp)
  178.             fatal("Cannot open temporary file");
  179.         }
  180.         if (argv[1]) {
  181.         fputs(argv[1],e_fp);
  182.         argc--,argv++;
  183.         }
  184.         (void)putc('\n', e_fp);
  185.         break;
  186.     case 'I':
  187. #ifdef TAINT
  188.         if (euid != uid || egid != gid)
  189.         fatal("No -I allowed in setuid scripts");
  190. #endif
  191.         str_cat(str,"-");
  192.         str_cat(str,s);
  193.         str_cat(str," ");
  194.         if (*++s) {
  195.         (void)apush(stab_array(incstab),str_make(s,0));
  196.         }
  197.         else if (argv[1]) {
  198.         (void)apush(stab_array(incstab),str_make(argv[1],0));
  199.         str_cat(str,argv[1]);
  200.         argc--,argv++;
  201.         str_cat(str," ");
  202.         }
  203.         break;
  204.     case 'P':
  205. #ifdef TAINT
  206.         if (euid != uid || egid != gid)
  207.         fatal("No -P allowed in setuid scripts");
  208. #endif
  209.         preprocess = TRUE;
  210.         s++;
  211.         goto reswitch;
  212.     case 's':
  213. #ifdef TAINT
  214.         if (euid != uid || egid != gid)
  215.         fatal("No -s allowed in setuid scripts");
  216. #endif
  217.         doswitches = TRUE;
  218.         s++;
  219.         goto reswitch;
  220.     case 'S':
  221. #ifdef TAINT
  222.         if (euid != uid || egid != gid)
  223.         fatal("No -S allowed in setuid scripts");
  224. #endif
  225.         dosearch = TRUE;
  226.         s++;
  227.         goto reswitch;
  228.     case 'x':
  229.         doextract = TRUE;
  230.         s++;
  231.         if (*s)
  232.         cddir = savestr(s);
  233.         break;
  234.     case '-':
  235.         argc--,argv++;
  236.         goto switch_end;
  237.     case 0:
  238.         break;
  239.     default:
  240.         fatal("Unrecognized switch: -%s",s);
  241.     }
  242.     }
  243.   switch_end:
  244.     scriptname = argv[0];
  245.     if (e_fp) {
  246.     (void)fclose(e_fp);
  247.     argc++,argv--;
  248.     scriptname = e_tmpname;
  249.     }
  250.  
  251. #ifdef MSDOS
  252. #define PERLLIB_SEP ';'
  253. #else
  254. #define PERLLIB_SEP ':'
  255. #endif
  256. #ifndef TAINT        /* Can't allow arbitrary PERLLIB in setuid script */
  257.     {
  258.     char * s2 = getenv("PERLLIB");
  259.  
  260.     if ( s2 ) {
  261.         /* Break at all separators */
  262.         while ( *s2 ) {
  263.         /* First, skip any consecutive separators */
  264.         while ( *s2 == PERLLIB_SEP ) {
  265.             /* Uncomment the next line for PATH semantics */
  266.             /* (void)apush(stab_array(incstab),str_make(".",1)); */
  267.             s2++;
  268.         }
  269.         if ( (s = index(s2,PERLLIB_SEP)) != Nullch ) {
  270.             (void)apush(stab_array(incstab),str_make(s2,(int)(s-s2)));
  271.             s2 = s+1;
  272.         } else {
  273.             (void)apush(stab_array(incstab),str_make(s2,0));
  274.             break;
  275.         }
  276.         }
  277.     }
  278.     }
  279. #endif /* TAINT */
  280.  
  281. #ifndef PRIVLIB
  282. #define PRIVLIB "/usr/local/lib/perl"
  283. #endif
  284.     (void)apush(stab_array(incstab),str_make(PRIVLIB,0));
  285.     (void)apush(stab_array(incstab),str_make(".",1));
  286.  
  287.     str_set(&str_no,No);
  288.     str_set(&str_yes,Yes);
  289.  
  290.     /* open script */
  291.  
  292.     if (scriptname == Nullch)
  293. #ifdef MSDOS
  294.     {
  295.     if ( isatty(fileno(stdin)) )
  296.       moreswitches("v");
  297.     scriptname = "-";
  298.     }
  299. #else
  300.     scriptname = "-";
  301. #endif
  302.     if (dosearch && !index(scriptname, '/') && (s = getenv("PATH"))) {
  303.     char *xfound = Nullch, *xfailed = Nullch;
  304.     int len;
  305.  
  306.     bufend = s + strlen(s);
  307.     while (*s) {
  308. #ifndef MSDOS
  309.         s = cpytill(tokenbuf,s,bufend,':',&len);
  310. #else
  311.         for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
  312.         tokenbuf[len] = '\0';
  313. #endif
  314.         if (*s)
  315.         s++;
  316. #ifndef MSDOS
  317.         if (len && tokenbuf[len-1] != '/')
  318. #else
  319.         if (len && tokenbuf[len-1] != '\\')
  320. #endif
  321.         (void)strcat(tokenbuf+len,"/");
  322.         (void)strcat(tokenbuf+len,scriptname);
  323. #ifdef DEBUGGING
  324.         if (debug & 1)
  325.         fprintf(stderr,"Looking for %s\n",tokenbuf);
  326. #endif
  327.         if (stat(tokenbuf,&statbuf) < 0)        /* not there? */
  328.         continue;
  329.         if (S_ISREG(statbuf.st_mode)
  330.          && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
  331.         xfound = tokenbuf;              /* bingo! */
  332.         break;
  333.         }
  334.         if (!xfailed)
  335.         xfailed = savestr(tokenbuf);
  336.     }
  337.     if (!xfound)
  338.         fatal("Can't execute %s", xfailed ? xfailed : scriptname );
  339.     if (xfailed)
  340.         Safefree(xfailed);
  341.     scriptname = savestr(xfound);
  342.     }
  343.  
  344.     fdpid = anew(Nullstab);    /* for remembering popen pids by fd */
  345.     pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */
  346.  
  347.     origfilename = savestr(scriptname);
  348.     curcmd->c_filestab = fstab(origfilename);
  349.     if (strEQ(origfilename,"-"))
  350.     scriptname = "";
  351.     if (preprocess) {
  352.     char *cpp = CPPSTDIN;
  353.  
  354.     if (strEQ(cpp,"cppstdin"))
  355.         sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
  356.     else
  357.         sprintf(tokenbuf, "%s", cpp);
  358.     str_cat(str,"-I");
  359.     str_cat(str,PRIVLIB);
  360. #ifdef sprite
  361.     (void)sprintf(buf, "\
  362. /sprite/cmds/sed -e '/^[^#]/b end' \
  363.  -e '/^#[     ]*include[     ]/b end' \
  364.  -e '/^#[     ]*define[     ]/b end' \
  365.  -e '/^#[     ]*if[     ]/b end' \
  366.  -e '/^#[     ]*ifdef[     ]/b end' \
  367.  -e '/^#[     ]*ifndef[     ]/b end' \
  368.  -e '/^#[     ]*else/b end' \
  369.  -e '/^#[     ]*endif/b end' \
  370.  -e 's/^#.*//' \
  371.  -e ': end' \
  372.  %s | %s -C %s %s",
  373.       argv[0], CPPSTDIN, str_get(str), CPPMINUS);
  374.  
  375. #else
  376.     (void)sprintf(buf, "\
  377. %ssed %s -e '/^[^#]/b' \
  378.  -e '/^#[     ]*include[     ]/b' \
  379.  -e '/^#[     ]*define[     ]/b' \
  380.  -e '/^#[     ]*if[     ]/b' \
  381.  -e '/^#[     ]*ifdef[     ]/b' \
  382.  -e '/^#[     ]*ifndef[     ]/b' \
  383.  -e '/^#[     ]*else/b' \
  384.  -e '/^#[     ]*elif[     ]/b' \
  385.  -e '/^#[     ]*undef[     ]/b' \
  386.  -e '/^#[     ]*endif/b' \
  387.  -e 's/^[     ]*#.*//' \
  388.  %s | %s -C %s %s",
  389. #ifdef MSDOS
  390.       "",
  391. #else
  392.       "/bin/",
  393. #endif
  394.       (doextract ? "-e '1,/^#/d\n'" : ""),
  395.       scriptname, tokenbuf, str_get(str), CPPMINUS);
  396. #ifdef DEBUGGING
  397.     if (debug & 64) {
  398.         fputs(buf,stderr);
  399.         fputs("\n",stderr);
  400.     }
  401. #endif
  402. #endif /*sprite*/
  403.     doextract = FALSE;
  404. #ifdef IAMSUID                /* actually, this is caught earlier */
  405.     if (euid != uid && !euid)    /* if running suidperl */
  406. #ifdef HAS_SETEUID
  407.         (void)seteuid(uid);        /* musn't stay setuid root */
  408. #else
  409. #ifdef HAS_SETREUID
  410.         (void)setreuid(-1, uid);
  411. #else
  412.         setuid(uid);
  413. #endif
  414. #endif
  415. #endif /* IAMSUID */
  416.     rsfp = mypopen(buf,"r");
  417.     }
  418.     else if (!*scriptname) {
  419. #ifdef TAINT
  420.     if (euid != uid || egid != gid)
  421.         fatal("Can't take set-id script from stdin");
  422. #endif
  423.     rsfp = stdin;
  424.     }
  425.     else
  426.     rsfp = fopen(scriptname,"r");
  427.     if ((FILE*)rsfp == Nullfp) {
  428. #ifdef DOSUID
  429. #ifndef IAMSUID        /* in case script is not readable before setuid */
  430.     if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 &&
  431.       statbuf.st_mode & (S_ISUID|S_ISGID)) {
  432.         (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
  433.         execv(buf, origargv);    /* try again */
  434.         fatal("Can't do setuid\n");
  435.     }
  436. #endif
  437. #endif
  438.     fatal("Can't open perl script \"%s\": %s\n",
  439.       stab_val(curcmd->c_filestab)->str_ptr, strerror(errno));
  440.     }
  441.     str_free(str);        /* free -I directories */
  442.     str = Nullstr;
  443.  
  444.     /* do we need to emulate setuid on scripts? */
  445.  
  446.     /* This code is for those BSD systems that have setuid #! scripts disabled
  447.      * in the kernel because of a security problem.  Merely defining DOSUID
  448.      * in perl will not fix that problem, but if you have disabled setuid
  449.      * scripts in the kernel, this will attempt to emulate setuid and setgid
  450.      * on scripts that have those now-otherwise-useless bits set.  The setuid
  451.      * root version must be called suidperl or sperlN.NNN.  If regular perl
  452.      * discovers that it has opened a setuid script, it calls suidperl with
  453.      * the same argv that it had.  If suidperl finds that the script it has
  454.      * just opened is NOT setuid root, it sets the effective uid back to the
  455.      * uid.  We don't just make perl setuid root because that loses the
  456.      * effective uid we had before invoking perl, if it was different from the
  457.      * uid.
  458.      *
  459.      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
  460.      * be defined in suidperl only.  suidperl must be setuid root.  The
  461.      * Configure script will set this up for you if you want it.
  462.      *
  463.      * There is also the possibility of have a script which is running
  464.      * set-id due to a C wrapper.  We want to do the TAINT checks
  465.      * on these set-id scripts, but don't want to have the overhead of
  466.      * them in normal perl, and can't use suidperl because it will lose
  467.      * the effective uid info, so we have an additional non-setuid root
  468.      * version called taintperl or tperlN.NNN that just does the TAINT checks.
  469.      */
  470.  
  471. #ifdef DOSUID
  472.     if (fstat(fileno(rsfp),&statbuf) < 0)    /* normal stat is insecure */
  473.     fatal("Can't stat script \"%s\"",origfilename);
  474.     if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
  475.     int len;
  476.  
  477. #ifdef IAMSUID
  478. #ifndef HAS_SETREUID
  479.     /* On this access check to make sure the directories are readable,
  480.      * there is actually a small window that the user could use to make
  481.      * filename point to an accessible directory.  So there is a faint
  482.      * chance that someone could execute a setuid script down in a
  483.      * non-accessible directory.  I don't know what to do about that.
  484.      * But I don't think it's too important.  The manual lies when
  485.      * it says access() is useful in setuid programs.
  486.      */
  487.     if (access(stab_val(curcmd->c_filestab)->str_ptr,1))    /*double check*/
  488.         fatal("Permission denied");
  489. #else
  490.     /* If we can swap euid and uid, then we can determine access rights
  491.      * with a simple stat of the file, and then compare device and
  492.      * inode to make sure we did stat() on the same file we opened.
  493.      * Then we just have to make sure he or she can execute it.
  494.      */
  495.     {
  496.         struct stat tmpstatbuf;
  497.  
  498.         if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
  499.         fatal("Can't swap uid and euid");    /* really paranoid */
  500.         if (stat(stab_val(curcmd->c_filestab)->str_ptr,&tmpstatbuf) < 0)
  501.         fatal("Permission denied");    /* testing full pathname here */
  502.         if (tmpstatbuf.st_dev != statbuf.st_dev ||
  503.         tmpstatbuf.st_ino != statbuf.st_ino) {
  504.         (void)fclose(rsfp);
  505.         if (rsfp = mypopen("/bin/mail root","w")) {    /* heh, heh */
  506.             fprintf(rsfp,
  507. "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
  508. (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
  509.             uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
  510.             statbuf.st_dev, statbuf.st_ino,
  511.             stab_val(curcmd->c_filestab)->str_ptr,
  512.             statbuf.st_uid, statbuf.st_gid);
  513.             (void)mypclose(rsfp);
  514.         }
  515.         fatal("Permission denied\n");
  516.         }
  517.         if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
  518.         fatal("Can't reswap uid and euid");
  519.         if (!cando(S_IXUSR,FALSE,&statbuf))        /* can real uid exec? */
  520.         fatal("Permission denied\n");
  521.     }
  522. #endif /* HAS_SETREUID */
  523. #endif /* IAMSUID */
  524.  
  525.     if (!S_ISREG(statbuf.st_mode))
  526.         fatal("Permission denied");
  527.     if (statbuf.st_mode & S_IWOTH)
  528.         fatal("Setuid/gid script is writable by world");
  529.     doswitches = FALSE;        /* -s is insecure in suid */
  530.     curcmd->c_line++;
  531.     if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
  532.       strnNE(tokenbuf,"#!",2) )    /* required even on Sys V */
  533.         fatal("No #! line");
  534.     s = tokenbuf+2;
  535.     if (*s == ' ') s++;
  536.     while (!isSPACE(*s)) s++;
  537.     if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
  538.         fatal("Not a perl script");
  539.     while (*s == ' ' || *s == '\t') s++;
  540.     /*
  541.      * #! arg must be what we saw above.  They can invoke it by
  542.      * mentioning suidperl explicitly, but they may not add any strange
  543.      * arguments beyond what #! says if they do invoke suidperl that way.
  544.      */
  545.     len = strlen(validarg);
  546.     if (strEQ(validarg," PHOOEY ") ||
  547.         strnNE(s,validarg,len) || !isSPACE(s[len]))
  548.         fatal("Args must match #! line");
  549.  
  550. #ifndef IAMSUID
  551.     if (euid != uid && (statbuf.st_mode & S_ISUID) &&
  552.         euid == statbuf.st_uid)
  553.         if (!do_undump)
  554.         fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
  555. FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
  556. #endif /* IAMSUID */
  557.  
  558.     if (euid) {    /* oops, we're not the setuid root perl */
  559.         (void)fclose(rsfp);
  560. #ifndef IAMSUID
  561.         (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
  562.         execv(buf, origargv);    /* try again */
  563. #endif
  564.         fatal("Can't do setuid\n");
  565.     }
  566.  
  567.     if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid)
  568. #ifdef HAS_SETEGID
  569.         (void)setegid(statbuf.st_gid);
  570. #else
  571. #ifdef HAS_SETREGID
  572.         (void)setregid((GIDTYPE)-1,statbuf.st_gid);
  573. #else
  574.         setgid(statbuf.st_gid);
  575. #endif
  576. #endif
  577.     if (statbuf.st_mode & S_ISUID) {
  578.         if (statbuf.st_uid != euid)
  579. #ifdef HAS_SETEUID
  580.         (void)seteuid(statbuf.st_uid);    /* all that for this */
  581. #else
  582. #ifdef HAS_SETREUID
  583.         (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
  584. #else
  585.         setuid(statbuf.st_uid);
  586. #endif
  587. #endif
  588.     }
  589.     else if (uid)            /* oops, mustn't run as root */
  590. #ifdef HAS_SETEUID
  591.         (void)seteuid((UIDTYPE)uid);
  592. #else
  593. #ifdef HAS_SETREUID
  594.         (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
  595. #else
  596.         setuid((UIDTYPE)uid);
  597. #endif
  598. #endif
  599.     uid = (int)getuid();
  600.     euid = (int)geteuid();
  601.     gid = (int)getgid();
  602.     egid = (int)getegid();
  603.     if (!cando(S_IXUSR,TRUE,&statbuf))
  604.         fatal("Permission denied\n");    /* they can't do this */
  605.     }
  606. #ifdef IAMSUID
  607.     else if (preprocess)
  608.     fatal("-P not allowed for setuid/setgid script\n");
  609.     else
  610.     fatal("Script is not setuid/setgid in suidperl\n");
  611. #else
  612. #ifndef TAINT        /* we aren't taintperl or suidperl */
  613.     /* script has a wrapper--can't run suidperl or we lose euid */
  614.     else if (euid != uid || egid != gid) {
  615.     (void)fclose(rsfp);
  616.     (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
  617.     execv(buf, origargv);    /* try again */
  618.     fatal("Can't run setuid script with taint checks");
  619.     }
  620. #endif /* TAINT */
  621. #endif /* IAMSUID */
  622. #else /* !DOSUID */
  623. #ifndef TAINT        /* we aren't taintperl or suidperl */
  624.     if (euid != uid || egid != gid) {    /* (suidperl doesn't exist, in fact) */
  625. #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
  626.     fstat(fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
  627.     if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
  628.         ||
  629.         (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
  630.        )
  631.         if (!do_undump)
  632.         fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
  633. FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
  634. #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
  635.     /* not set-id, must be wrapped */
  636.     (void)fclose(rsfp);
  637.     (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
  638.     execv(buf, origargv);    /* try again */
  639.     fatal("Can't run setuid script with taint checks");
  640.     }
  641. #endif /* TAINT */
  642. #endif /* DOSUID */
  643.  
  644. #if !defined(IAMSUID) && !defined(TAINT)
  645.  
  646.     /* skip forward in input to the real script? */
  647.  
  648.     while (doextract) {
  649.     if ((s = str_gets(linestr, rsfp, 0)) == Nullch)
  650.         fatal("No Perl script found in input\n");
  651.     if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
  652.         ungetc('\n',rsfp);        /* to keep line count right */
  653.         doextract = FALSE;
  654.         if (s = instr(s,"perl -")) {
  655.         s += 6;
  656.         /*SUPPRESS 530*/
  657.         while (s = moreswitches(s)) ;
  658.         }
  659.         if (cddir && chdir(cddir) < 0)
  660.         fatal("Can't chdir to %s",cddir);
  661.     }
  662.     }
  663. #endif /* !defined(IAMSUID) && !defined(TAINT) */
  664.  
  665.     defstab = stabent("_",TRUE);
  666.  
  667.     subname = str_make("main",4);
  668.     if (perldb) {
  669.     debstash = hnew(0);
  670.     stab_xhash(stabent("_DB",TRUE)) = debstash;
  671.     curstash = debstash;
  672.     dbargs = stab_xarray(aadd((tmpstab = stabent("args",TRUE))));
  673.     tmpstab->str_pok |= SP_MULTI;
  674.     dbargs->ary_flags = 0;
  675.     DBstab = stabent("DB",TRUE);
  676.     DBstab->str_pok |= SP_MULTI;
  677.     DBline = stabent("dbline",TRUE);
  678.     DBline->str_pok |= SP_MULTI;
  679.     DBsub = hadd(tmpstab = stabent("sub",TRUE));
  680.     tmpstab->str_pok |= SP_MULTI;
  681.     DBsingle = stab_val((tmpstab = stabent("single",TRUE)));
  682.     tmpstab->str_pok |= SP_MULTI;
  683.     DBtrace = stab_val((tmpstab = stabent("trace",TRUE)));
  684.     tmpstab->str_pok |= SP_MULTI;
  685.     DBsignal = stab_val((tmpstab = stabent("signal",TRUE)));
  686.     tmpstab->str_pok |= SP_MULTI;
  687.     curstash = defstash;
  688.     }
  689.  
  690.     /* init tokener */
  691.  
  692.     bufend = bufptr = str_get(linestr);
  693.  
  694.     savestack = anew(Nullstab);        /* for saving non-local values */
  695.     stack = anew(Nullstab);        /* for saving non-local values */
  696.     stack->ary_flags = 0;        /* not a real array */
  697.     afill(stack,63); afill(stack,-1);    /* preextend stack */
  698.     afill(savestack,63); afill(savestack,-1);
  699.  
  700.     /* now parse the script */
  701.  
  702.     error_count = 0;
  703.     if (yyparse() || error_count) {
  704.     if (minus_c)
  705.         fatal("%s had compilation errors.\n", origfilename);
  706.     else {
  707.         fatal("Execution of %s aborted due to compilation errors.\n",
  708.         origfilename);
  709.     }
  710.     }
  711.  
  712.     New(50,loop_stack,128,struct loop);
  713. #ifdef DEBUGGING
  714.     if (debug) {
  715.     New(51,debname,128,char);
  716.     New(52,debdelim,128,char);
  717.     }
  718. #endif
  719.     curstash = defstash;
  720.  
  721.     preprocess = FALSE;
  722.     if (e_fp) {
  723.     e_fp = Nullfp;
  724.     (void)UNLINK(e_tmpname);
  725.     }
  726.  
  727.     /* initialize everything that won't change if we undump */
  728.  
  729.     if (sigstab = stabent("SIG",allstabs)) {
  730.     sigstab->str_pok |= SP_MULTI;
  731.     (void)hadd(sigstab);
  732.     }
  733.  
  734.     magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\020\024\027\006");
  735.     userinit();        /* in case linked C routines want magical variables */
  736.  
  737.     amperstab = stabent("&",allstabs);
  738.     leftstab = stabent("`",allstabs);
  739.     rightstab = stabent("'",allstabs);
  740.     sawampersand = (amperstab || leftstab || rightstab);
  741.     if (tmpstab = stabent(":",allstabs))
  742.     str_set(STAB_STR(tmpstab),chopset);
  743.     if (tmpstab = stabent("\024",allstabs))
  744.     time(&basetime);
  745.  
  746.     /* these aren't necessarily magical */
  747.     if (tmpstab = stabent(";",allstabs))
  748.     str_set(STAB_STR(tmpstab),"\034");
  749.     if (tmpstab = stabent("]",allstabs)) {
  750.     str = STAB_STR(tmpstab);
  751.     str_set(str,rcsid);
  752.     str->str_u.str_nval = atof(patchlevel);
  753.     str->str_nok = 1;
  754.     }
  755.     str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
  756.  
  757.     stdinstab = stabent("STDIN",TRUE);
  758.     stdinstab->str_pok |= SP_MULTI;
  759.     stab_io(stdinstab) = stio_new();
  760.     stab_io(stdinstab)->ifp = stdin;
  761.     tmpstab = stabent("stdin",TRUE);
  762.     stab_io(tmpstab) = stab_io(stdinstab);
  763.     tmpstab->str_pok |= SP_MULTI;
  764.  
  765.     tmpstab = stabent("STDOUT",TRUE);
  766.     tmpstab->str_pok |= SP_MULTI;
  767.     stab_io(tmpstab) = stio_new();
  768.     stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout;
  769.     defoutstab = tmpstab;
  770.     tmpstab = stabent("stdout",TRUE);
  771.     stab_io(tmpstab) = stab_io(defoutstab);
  772.     tmpstab->str_pok |= SP_MULTI;
  773.  
  774.     curoutstab = stabent("STDERR",TRUE);
  775.     curoutstab->str_pok |= SP_MULTI;
  776.     stab_io(curoutstab) = stio_new();
  777.     stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr;
  778.     tmpstab = stabent("stderr",TRUE);
  779.     stab_io(tmpstab) = stab_io(curoutstab);
  780.     tmpstab->str_pok |= SP_MULTI;
  781.     curoutstab = defoutstab;        /* switch back to STDOUT */
  782.  
  783.     statname = Str_new(66,0);        /* last filename we did stat on */
  784.  
  785.     /* now that script is parsed, we can modify record separator */
  786.  
  787.     rs = nrs;
  788.     rslen = nrslen;
  789.     rschar = nrschar;
  790.     str_nset(stab_val(stabent("/", TRUE)), rs, rslen);
  791.  
  792.     if (do_undump)
  793.     my_unexec();
  794.  
  795.   just_doit:        /* come here if running an undumped a.out */
  796.     argc--,argv++;    /* skip name of script */
  797.     if (doswitches) {
  798.     for (; argc > 0 && **argv == '-'; argc--,argv++) {
  799.         if (argv[0][1] == '-') {
  800.         argc--,argv++;
  801.         break;
  802.         }
  803.         if (s = index(argv[0], '=')) {
  804.         *s++ = '\0';
  805.         str_set(stab_val(stabent(argv[0]+1,TRUE)),s);
  806.         }
  807.         else
  808.         str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
  809.     }
  810.     }
  811. #ifdef TAINT
  812.     tainted = 1;
  813. #endif
  814.     if (tmpstab = stabent("0",allstabs)) {
  815.     str_set(stab_val(tmpstab),origfilename);
  816.     magicname("0", Nullch, 0);
  817.     }
  818.     if (tmpstab = stabent("\030",allstabs))
  819.     str_set(stab_val(tmpstab),origargv[0]);
  820.     if (argvstab = stabent("ARGV",allstabs)) {
  821.     argvstab->str_pok |= SP_MULTI;
  822.     (void)aadd(argvstab);
  823.     aclear(stab_array(argvstab));
  824.     for (; argc > 0; argc--,argv++) {
  825.         (void)apush(stab_array(argvstab),str_make(argv[0],0));
  826.     }
  827.     }
  828. #ifdef TAINT
  829.     (void) stabent("ENV",TRUE);        /* must test PATH and IFS */
  830. #endif
  831.     if (envstab = stabent("ENV",allstabs)) {
  832.     envstab->str_pok |= SP_MULTI;
  833.     (void)hadd(envstab);
  834.     hclear(stab_hash(envstab), FALSE);
  835.     if (env != environ)
  836.         environ[0] = Nullch;
  837.     for (; *env; env++) {
  838.         if (!(s = index(*env,'=')))
  839.         continue;
  840.         *s++ = '\0';
  841.         str = str_make(s--,0);
  842.         str_magic(str, envstab, 'E', *env, s - *env);
  843.         (void)hstore(stab_hash(envstab), *env, s - *env, str, 0);
  844.         *s = '=';
  845.     }
  846.     }
  847. #ifdef TAINT
  848.     tainted = 0;
  849. #endif
  850.     if (tmpstab = stabent("$",allstabs))
  851.     str_numset(STAB_STR(tmpstab),(double)getpid());
  852.  
  853.     if (dowarn) {
  854.     stab_check('A','Z');
  855.     stab_check('a','z');
  856.     }
  857.  
  858.     if (setjmp(top_env))    /* sets goto_targ on longjump */
  859.     loop_ptr = -1;        /* start label stack again */
  860.  
  861. #ifdef DEBUGGING
  862.     if (debug & 1024)
  863.     dump_all();
  864.     if (debug)
  865.     fprintf(stderr,"\nEXECUTING...\n\n");
  866. #endif
  867.  
  868.     if (minus_c) {
  869.     fprintf(stderr,"%s syntax OK\n", origfilename);
  870.     exit(0);
  871.     }
  872.  
  873.     /* do it */
  874.  
  875.     (void) cmd_exec(main_root,G_SCALAR,-1);
  876.  
  877.     if (goto_targ)
  878.     fatal("Can't find label \"%s\"--aborting",goto_targ);
  879.     exit(0);
  880.     /* NOTREACHED */
  881. }
  882.  
  883. void
  884. magicalize(list)
  885. register char *list;
  886. {
  887.     char sym[2];
  888.  
  889.     sym[1] = '\0';
  890.     while (*sym = *list++)
  891.     magicname(sym, Nullch, 0);
  892. }
  893.  
  894. void
  895. magicname(sym,name,namlen)
  896. char *sym;
  897. char *name;
  898. int namlen;
  899. {
  900.     register STAB *stab;
  901.  
  902.     if (stab = stabent(sym,allstabs)) {
  903.     stab_flags(stab) = SF_VMAGIC;
  904.     str_magic(stab_val(stab), stab, 0, name, namlen);
  905.     }
  906. }
  907.  
  908. void
  909. savelines(array, str)
  910. ARRAY *array;
  911. STR *str;
  912. {
  913.     register char *s = str->str_ptr;
  914.     register char *send = str->str_ptr + str->str_cur;
  915.     register char *t;
  916.     register int line = 1;
  917.  
  918.     while (s && s < send) {
  919.     STR *tmpstr = Str_new(85,0);
  920.  
  921.     t = index(s, '\n');
  922.     if (t)
  923.         t++;
  924.     else
  925.         t = send;
  926.  
  927.     str_nset(tmpstr, s, t - s);
  928.     astore(array, line++, tmpstr);
  929.     s = t;
  930.     }
  931. }
  932.  
  933. /* this routine is in perl.c by virtue of being sort of an alternate main() */
  934.  
  935. int
  936. do_eval(str,optype,stash,savecmd,gimme,arglast)
  937. STR *str;
  938. int optype;
  939. HASH *stash;
  940. int savecmd;
  941. int gimme;
  942. int *arglast;
  943. {
  944.     STR **st = stack->ary_array;
  945.     int retval;
  946.     CMD *myroot = Nullcmd;
  947.     ARRAY *ar;
  948.     int i;
  949.     CMD * VOLATILE oldcurcmd = curcmd;
  950.     VOLATILE int oldtmps_base = tmps_base;
  951.     VOLATILE int oldsave = savestack->ary_fill;
  952.     VOLATILE int oldperldb = perldb;
  953.     SPAT * VOLATILE oldspat = curspat;
  954.     SPAT * VOLATILE oldlspat = lastspat;
  955.     static char *last_eval = Nullch;
  956.     static long last_elen = 0;
  957.     static CMD *last_root = Nullcmd;
  958.     VOLATILE int sp = arglast[0];
  959.     char *specfilename;
  960.     char *tmpfilename;
  961.     int parsing = 1;
  962.  
  963.     tmps_base = tmps_max;
  964.     if (curstash != stash) {
  965.     (void)savehptr(&curstash);
  966.     curstash = stash;
  967.     }
  968.     str_set(stab_val(stabent("@",TRUE)),"");
  969.     if (curcmd->c_line == 0)        /* don't debug debugger... */
  970.     perldb = FALSE;
  971.     curcmd = &compiling;
  972.     if (optype == O_EVAL) {        /* normal eval */
  973.     curcmd->c_filestab = fstab("(eval)");
  974.     curcmd->c_line = 1;
  975.     str_sset(linestr,str);
  976.     str_cat(linestr,";\n");        /* be kind to them */
  977.     if (perldb)
  978.         savelines(stab_xarray(curcmd->c_filestab), linestr);
  979.     }
  980.     else {
  981.     if (last_root && !in_eval) {
  982.         Safefree(last_eval);
  983.         last_eval = Nullch;
  984.         cmd_free(last_root);
  985.         last_root = Nullcmd;
  986.     }
  987.     specfilename = str_get(str);
  988.     str_set(linestr,"");
  989.     if (optype == O_REQUIRE && &str_undef !=
  990.       hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) {
  991.         curcmd = oldcurcmd;
  992.         tmps_base = oldtmps_base;
  993.         st[++sp] = &str_yes;
  994.         perldb = oldperldb;
  995.         return sp;
  996.     }
  997.     tmpfilename = savestr(specfilename);
  998.     if (index("/.", *tmpfilename))
  999.         rsfp = fopen(tmpfilename,"r");
  1000.     else {
  1001.         ar = stab_array(incstab);
  1002.         for (i = 0; i <= ar->ary_fill; i++) {
  1003.         (void)sprintf(buf, "%s/%s",
  1004.           str_get(afetch(ar,i,TRUE)), specfilename);
  1005.         rsfp = fopen(buf,"r");
  1006.         if (rsfp) {
  1007.             char *s = buf;
  1008.  
  1009.             if (*s == '.' && s[1] == '/')
  1010.             s += 2;
  1011.             Safefree(tmpfilename);
  1012.             tmpfilename = savestr(s);
  1013.             break;
  1014.         }
  1015.         }
  1016.     }
  1017.     curcmd->c_filestab = fstab(tmpfilename);
  1018.     Safefree(tmpfilename);
  1019.     tmpfilename = Nullch;
  1020.     if (!rsfp) {
  1021.         curcmd = oldcurcmd;
  1022.         tmps_base = oldtmps_base;
  1023.         if (optype == O_REQUIRE) {
  1024.         sprintf(tokenbuf,"Can't locate %s in @INC", specfilename);
  1025.         if (instr(tokenbuf,".h "))
  1026.             strcat(tokenbuf," (change .h to .ph maybe?)");
  1027.         if (instr(tokenbuf,".ph "))
  1028.             strcat(tokenbuf," (did you run h2ph?)");
  1029.         fatal("%s",tokenbuf);
  1030.         }
  1031.         if (gimme != G_ARRAY)
  1032.         st[++sp] = &str_undef;
  1033.         perldb = oldperldb;
  1034.         return sp;
  1035.     }
  1036.     curcmd->c_line = 0;
  1037.     }
  1038.     in_eval++;
  1039.     oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
  1040.     bufend = bufptr + linestr->str_cur;
  1041.     if (++loop_ptr >= loop_max) {
  1042.     loop_max += 128;
  1043.     Renew(loop_stack, loop_max, struct loop);
  1044.     }
  1045.     loop_stack[loop_ptr].loop_label = "_EVAL_";
  1046.     loop_stack[loop_ptr].loop_sp = sp;
  1047. #ifdef DEBUGGING
  1048.     if (debug & 4) {
  1049.     deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
  1050.     }
  1051. #endif
  1052.     eval_root = Nullcmd;
  1053.     if (setjmp(loop_stack[loop_ptr].loop_env)) {
  1054.     retval = 1;
  1055.     }
  1056.     else {
  1057.     error_count = 0;
  1058.     if (rsfp) {
  1059.         retval = yyparse();
  1060.         retval |= error_count;
  1061.     }
  1062.     else if (last_root && last_elen == bufend - bufptr
  1063.       && *bufptr == *last_eval && !bcmp(bufptr,last_eval,last_elen)){
  1064.         retval = 0;
  1065.         eval_root = last_root;    /* no point in reparsing */
  1066.     }
  1067.     else if (in_eval == 1 && !savecmd) {
  1068.         if (last_root) {
  1069.         Safefree(last_eval);
  1070.         last_eval = Nullch;
  1071.         cmd_free(last_root);
  1072.         }
  1073.         last_root = Nullcmd;
  1074.         last_elen = bufend - bufptr;
  1075.         last_eval = nsavestr(bufptr, last_elen);
  1076.         retval = yyparse();
  1077.         retval |= error_count;
  1078.         if (!retval)
  1079.         last_root = eval_root;
  1080.         if (!last_root) {
  1081.         Safefree(last_eval);
  1082.         last_eval = Nullch;
  1083.         }
  1084.     }
  1085.     else
  1086.         retval = yyparse();
  1087.     }
  1088.     myroot = eval_root;        /* in case cmd_exec does another eval! */
  1089.  
  1090.     if (retval) {
  1091.     st = stack->ary_array;
  1092.     sp = arglast[0];
  1093.     if (gimme != G_ARRAY)
  1094.         st[++sp] = &str_undef;
  1095.     if (parsing) {
  1096. #ifndef MANGLEDPARSE
  1097. #ifdef DEBUGGING
  1098.         if (debug & 128)
  1099.         fprintf(stderr,"Freeing eval_root %lx\n",(long)eval_root);
  1100. #endif
  1101.         cmd_free(eval_root);
  1102. #endif
  1103.         if ((CMD*)eval_root == last_root)
  1104.         last_root = Nullcmd;
  1105.         eval_root = myroot = Nullcmd;
  1106.     }
  1107.     if (rsfp) {
  1108.         fclose(rsfp);
  1109.         rsfp = 0;
  1110.     }
  1111.     }
  1112.     else {
  1113.     parsing = 0;
  1114.     sp = cmd_exec(eval_root,gimme,sp);
  1115.     st = stack->ary_array;
  1116.     for (i = arglast[0] + 1; i <= sp; i++)
  1117.         st[i] = str_mortal(st[i]);
  1118.                 /* if we don't save result, free zaps it */
  1119.     if (savecmd)
  1120.         eval_root = myroot;
  1121.     else if (in_eval != 1 && myroot != last_root)
  1122.         cmd_free(myroot);
  1123.     }
  1124.  
  1125.     perldb = oldperldb;
  1126.     in_eval--;
  1127. #ifdef DEBUGGING
  1128.     if (debug & 4) {
  1129.     char *tmps = loop_stack[loop_ptr].loop_label;
  1130.     deb("(Popping label #%d %s)\n",loop_ptr,
  1131.         tmps ? tmps : "" );
  1132.     }
  1133. #endif
  1134.     loop_ptr--;
  1135.     tmps_base = oldtmps_base;
  1136.     curspat = oldspat;
  1137.     lastspat = oldlspat;
  1138.     if (savestack->ary_fill > oldsave)    /* let them use local() */
  1139.     restorelist(oldsave);
  1140.  
  1141.     if (optype != O_EVAL) {
  1142.     if (retval) {
  1143.         if (optype == O_REQUIRE)
  1144.         fatal("%s", str_get(stab_val(stabent("@",TRUE))));
  1145.     }
  1146.     else {
  1147.         curcmd = oldcurcmd;
  1148.         if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) {
  1149.         (void)hstore(stab_hash(incstab), specfilename,
  1150.           strlen(specfilename), str_smake(stab_val(curcmd->c_filestab)),
  1151.               0 );
  1152.         }
  1153.         else if (optype == O_REQUIRE)
  1154.         fatal("%s did not return a true value", specfilename);
  1155.     }
  1156.     }
  1157.     curcmd = oldcurcmd;
  1158.     return sp;
  1159. }
  1160.  
  1161. int
  1162. do_try(cmd,gimme,arglast)
  1163. CMD *cmd;
  1164. int gimme;
  1165. int *arglast;
  1166. {
  1167.     STR **st = stack->ary_array;
  1168.  
  1169.     CMD * VOLATILE oldcurcmd = curcmd;
  1170.     VOLATILE int oldtmps_base = tmps_base;
  1171.     VOLATILE int oldsave = savestack->ary_fill;
  1172.     SPAT * VOLATILE oldspat = curspat;
  1173.     SPAT * VOLATILE oldlspat = lastspat;
  1174.     VOLATILE int sp = arglast[0];
  1175.  
  1176.     tmps_base = tmps_max;
  1177.     str_set(stab_val(stabent("@",TRUE)),"");
  1178.     in_eval++;
  1179.     if (++loop_ptr >= loop_max) {
  1180.     loop_max += 128;
  1181.     Renew(loop_stack, loop_max, struct loop);
  1182.     }
  1183.     loop_stack[loop_ptr].loop_label = "_EVAL_";
  1184.     loop_stack[loop_ptr].loop_sp = sp;
  1185. #ifdef DEBUGGING
  1186.     if (debug & 4) {
  1187.     deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
  1188.     }
  1189. #endif
  1190.     if (setjmp(loop_stack[loop_ptr].loop_env)) {
  1191.     st = stack->ary_array;
  1192.     sp = arglast[0];
  1193.     if (gimme != G_ARRAY)
  1194.         st[++sp] = &str_undef;
  1195.     }
  1196.     else {
  1197.     sp = cmd_exec(cmd,gimme,sp);
  1198.     st = stack->ary_array;
  1199. /*    for (i = arglast[0] + 1; i <= sp; i++)
  1200.         st[i] = str_mortal(st[i]);  not needed, I think */
  1201.                 /* if we don't save result, free zaps it */
  1202.     }
  1203.  
  1204.     in_eval--;
  1205. #ifdef DEBUGGING
  1206.     if (debug & 4) {
  1207.     char *tmps = loop_stack[loop_ptr].loop_label;
  1208.     deb("(Popping label #%d %s)\n",loop_ptr,
  1209.         tmps ? tmps : "" );
  1210.     }
  1211. #endif
  1212.     loop_ptr--;
  1213.     tmps_base = oldtmps_base;
  1214.     curspat = oldspat;
  1215.     lastspat = oldlspat;
  1216.     curcmd = oldcurcmd;
  1217.     if (savestack->ary_fill > oldsave)    /* let them use local() */
  1218.     restorelist(oldsave);
  1219.  
  1220.     return sp;
  1221. }
  1222.  
  1223. /* This routine handles any switches that can be given during run */
  1224.  
  1225. static char *
  1226. moreswitches(s)
  1227. char *s;
  1228. {
  1229.     int numlen;
  1230.  
  1231.     switch (*s) {
  1232.     case '0':
  1233.     nrschar = scanoct(s, 4, &numlen);
  1234.     nrs = nsavestr("\n",1);
  1235.     *nrs = nrschar;
  1236.     if (nrschar > 0377) {
  1237.         nrslen = 0;
  1238.         nrs = "";
  1239.     }
  1240.     else if (!nrschar && numlen >= 2) {
  1241.         nrslen = 2;
  1242.         nrs = "\n\n";
  1243.         nrschar = '\n';
  1244.     }
  1245.     return s + numlen;
  1246.     case 'a':
  1247.     minus_a = TRUE;
  1248.     s++;
  1249.     return s;
  1250.     case 'c':
  1251.     minus_c = TRUE;
  1252.     s++;
  1253.     return s;
  1254.     case 'd':
  1255. #ifdef TAINT
  1256.     if (euid != uid || egid != gid)
  1257.         fatal("No -d allowed in setuid scripts");
  1258. #endif
  1259.     perldb = TRUE;
  1260.     s++;
  1261.     return s;
  1262.     case 'D':
  1263. #ifdef DEBUGGING
  1264. #ifdef TAINT
  1265.     if (euid != uid || egid != gid)
  1266.         fatal("No -D allowed in setuid scripts");
  1267. #endif
  1268.     debug = atoi(s+1) | 32768;
  1269. #else
  1270.     warn("Recompile perl with -DDEBUGGING to use -D switch\n");
  1271. #endif
  1272.     /*SUPPRESS 530*/
  1273.     for (s++; isDIGIT(*s); s++) ;
  1274.     return s;
  1275.     case 'i':
  1276.     inplace = savestr(s+1);
  1277.     /*SUPPRESS 530*/
  1278.     for (s = inplace; *s && !isSPACE(*s); s++) ;
  1279.     *s = '\0';
  1280.     break;
  1281.     case 'I':
  1282. #ifdef TAINT
  1283.     if (euid != uid || egid != gid)
  1284.         fatal("No -I allowed in setuid scripts");
  1285. #endif
  1286.     if (*++s) {
  1287.         (void)apush(stab_array(incstab),str_make(s,0));
  1288.     }
  1289.     else
  1290.         fatal("No space allowed after -I");
  1291.     break;
  1292.     case 'l':
  1293.     minus_l = TRUE;
  1294.     s++;
  1295.     if (isDIGIT(*s)) {
  1296.         ors = savestr("\n");
  1297.         orslen = 1;
  1298.         *ors = scanoct(s, 3 + (*s == '0'), &numlen);
  1299.         s += numlen;
  1300.     }
  1301.     else {
  1302.         ors = nsavestr(nrs,nrslen);
  1303.         orslen = nrslen;
  1304.     }
  1305.     return s;
  1306.     case 'n':
  1307.     minus_n = TRUE;
  1308.     s++;
  1309.     return s;
  1310.     case 'p':
  1311.     minus_p = TRUE;
  1312.     s++;
  1313.     return s;
  1314.     case 'u':
  1315.     do_undump = TRUE;
  1316.     s++;
  1317.     return s;
  1318.     case 'U':
  1319.     unsafe = TRUE;
  1320.     s++;
  1321.     return s;
  1322.     case 'v':
  1323.     fputs("\nThis is perl, version 4.0\n\n",stdout);
  1324.     fputs(rcsid,stdout);
  1325.     fputs("\nCopyright (c) 1989, 1990, 1991, Larry Wall\n",stdout);
  1326. #ifdef MSDOS
  1327.     fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
  1328.     stdout);
  1329. #ifdef OS2
  1330.         fputs("OS/2 port Copyright (c) 1990, Raymond Chen, Kai Uwe Rommel\n",
  1331.         stdout);
  1332. #endif
  1333. #endif
  1334.     fputs("\n\
  1335. Perl may be copied only under the terms of either the Artistic License or the\n\
  1336. GNU General Public License, which may be found in the Perl 4.0 source kit.\n",stdout);
  1337. #ifdef MSDOS
  1338.         usage(origargv[0]);
  1339. #endif
  1340.     exit(0);
  1341.     case 'w':
  1342.     dowarn = TRUE;
  1343.     s++;
  1344.     return s;
  1345.     case ' ':
  1346.     case '\n':
  1347.     case '\t':
  1348.     break;
  1349.     default:
  1350.     fatal("Switch meaningless after -x: -%s",s);
  1351.     }
  1352.     return Nullch;
  1353. }
  1354.  
  1355. /* compliments of Tom Christiansen */
  1356.  
  1357. /* unexec() can be found in the Gnu emacs distribution */
  1358.  
  1359. my_unexec()
  1360. {
  1361. #ifdef UNEXEC
  1362.     int    status;
  1363.     extern int etext;
  1364.     static char dumpname[BUFSIZ];
  1365.     static char perlpath[256];
  1366.  
  1367.     sprintf (dumpname, "%s.perldump", origfilename);
  1368.     sprintf (perlpath, "%s/perl", BIN);
  1369.  
  1370.     status = unexec(dumpname, perlpath, &etext, sbrk(0), 0);
  1371.     if (status)
  1372.     fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname);
  1373.     exit(status);
  1374. #else
  1375. #ifdef MSDOS
  1376.     abort();    /* nothing else to do */
  1377. #else /* ! MSDOS */
  1378. #   ifndef SIGABRT
  1379. #    define SIGABRT SIGILL
  1380. #   endif
  1381. #   ifndef SIGILL
  1382. #    define SIGILL 6        /* blech */
  1383. #   endif
  1384.     kill(getpid(),SIGABRT);    /* for use with undump */
  1385. #endif /* ! MSDOS */
  1386. #endif
  1387. }
  1388.  
  1389.